Experimental BBS Explossion 3/Experimental BBS Explossion III.iso/pascal/fastdir.zip/FASTDIR.PAS

Pascal/Delphi Source File | 1993-06-15 | 37.4 KB | 1,359 lines

{ Default Compiler Directives}
{$S-,R-,V-,I-,N-,B-,F-}

{$IFNDEF Ver40}
  {Allow overlays}
  {$F+,O-,X+,A-}
{$ENDIF}

UNIT FASTDIR;

INTERFACE

USES Dos;

CONST

    MaxDirSize = 4096;

    Erased  : WORD = $09;
    Moved   : WORD = $0F;

    ShowFileType : BOOLEAN = FALSE;
    DoFullSearch : BOOLEAN = TRUE;  { used for FIND_FILEPATH to search all DIRS }
    NoShow       : WORD = Directory + Hidden + VolumeID;
    CurrentLess  : CHAR = 'n';
    SilentDirStr : PATHSTR = '';    { hidden directory ?? }

TYPE

    FileTypes = (fARC, fPAK, fZIP, fLZH, fARJ, fZOO, fLBR, fCOM, fEXE, fBAT,
                 fSFX, fDIR, fVOL, fOTHER, fERROR);

    DirPtr   = ^DirRec;
    DirRec   = RECORD
                 fType  : FILETYPES;
                 Attr   : WORD;
                 Time   : LONGINT;
                 PSize,
                 Size   : LONGINT;
                 Method,
                 Name   : STRING [12];
                 Path   : PathStr;
                 Tag    : BOOLEAN;
                 Next,
                 Prev   : DirPtr;
               END;

  LessFunc = FUNCTION (X, Y : DirPtr) : BOOLEAN;
  SortPPtr = ^Sortpage;
  SortPage = ARRAY [0..PRED(MaxDirSize)] OF DirPtr;

  DirList  = RECORD
             Root,
             Last,
             Current  : DirPtr;         { Points to Root,Last,Current items }
             Path     : PathStr;        { Dir Path Or Archive Name }
             Mask     : PathStr;        { Command Line or params }
             ArcType  : FILETYPES;      { DIR or Type of Archive }
             Recurse  : BOOLEAN;        { Include SUBS Too }
             Count,
             Tagged   : INTEGER;
             Space,
             TSpace   : LONGINT;
             Less     : LessFunc;       { Sort function }
             END;

  ExtractorRec = RECORD
                 Extract  : PathStr;
                 Compress : PathStr;
                 ListChar : Char;
                 END;

CONST

  Extractors : ARRAY [fARC .. fARJ] OF ExtractorRec = (

    (Extract  : 'ARC.EXE e';
     Compress : 'ARC.EXE a';
     ListChar : #32),

    (Extract  : 'PAK.EXE e /wa';
     Compress : 'PAK.EXE -a';
     ListChar : #32),

    (Extract  : 'PKUNZIP.EXE -o';
     Compress : 'PKZIP.EXE -ex';
     ListChar : '@'),

    (Extract  : 'LHARC.EXE -cm';
     Compress : 'LHARC.EXE a';
     ListChar : #32),

    (Extract  : 'ARJ.EXE e -y';
     Compress : 'ARJ.EXE a';
     ListChar : '!') );

FUNCTION  LessName (X, Y : DirPtr) : BOOLEAN;
FUNCTION  LessExt  (X, Y : DirPtr) : BOOLEAN;
FUNCTION  LessPath (X, Y : DirPtr) : BOOLEAN;
FUNCTION  LessSize (X, Y : DirPtr) : BOOLEAN;
FUNCTION  LessTime (X, Y : DirPtr) : BOOLEAN;
FUNCTION  LessAttr (X, Y : DirPtr) : BOOLEAN;

FUNCTION  FileTypePerExtension(fName : PathStr) : FileTypes;
FUNCTION  FileTypeString (FT : FileTypes) : STRING;
FUNCTION  GetArcType (FName : PathStr) : FileTypes;

PROCEDURE InitializeDir (VAR Dir : DirList);
PROCEDURE FindFiles (VAR Dir : DirList; SearchPath : PathStr);
PROCEDURE SortFiles (VAR Dir : DirList);
PROCEDURE ReleaseFiles (VAR Dir : DirList);
PROCEDURE SetLess (VAR Dir : DirList; LChar : CHAR);
PROCEDURE GetCommandLine (VAR Mask : PathStr);      { Get MASK from command line     }

PROCEDURE UpdateNextPrev (VAR Dir : DirList);
FUNCTION  NthDirItem (VAR Dir : DirList; Item : INTEGER) : DirPtr;

FUNCTION  IsDir(fName : PathStr) : BOOLEAN;
FUNCTION  IsArchive(fName : PathStr) : BOOLEAN;

PROCEDURE ZipView(VAR Dir : DirList; ZIPFile : String);  { handle ZIP File }
PROCEDURE ArjView(VAR Dir : DirList; ArjFile : String);  { handle ARJ File }
PROCEDURE LzhView(VAR Dir : DirList; LzhFile : String);  { handle LZH File }
PROCEDURE ArcView(VAR Dir : DirList; ArcName : PathStr); { handle ARC,PAK File }

PROCEDURE GetFiles(VAR Dir : DirList; Path,Mask : PathStr; Sort : LessFunc);

{ Interfaced for TEST program }
FUNCTION  PadR (InpStr : STRING; FieldLen : BYTE) : STRING;
FUNCTION  PadL(InpStr : STRING; Len : Byte) : STRING;
FUNCTION  FullPathname (Path, FileMask : PathStr) : PathStr;

IMPLEMENTATION

{ ╔════════════════════════════════════════════════════════════════════════╗ }
{ ║                 STRING FUNCTIONS AND PROCEDURES                        ║ }
{ ╚════════════════════════════════════════════════════════════════════════╝ }


Procedure StrUpr(Var S: String); Assembler;
Asm
  push    ds              { Save DS on stack }
  lds     si, S           { Load DS:SI With Pointer to S }
  cld                     { Clear direction flag - String instr. Forward }
  lodsb                   { Load first Byte of S (String length Byte) }
  sub     ah, ah          { Clear high Byte of AX }
  mov     cx, ax          { Move AX in CX }
  jcxz    @Done           { Length = 0, done }
  mov     ax, ds          { Set ES to the value in DS through AX }
  mov     es, ax          { (can't move between two segment Registers) }
  mov     di, si          { DI and SI now point to the first Char. }
@UpCase:
  lodsb                   { Load Character }
  cmp     al, 'a'
  jb      @notLower       { below 'a' -- store as is }
  cmp     al, 'z'
  ja      @notLower       { above 'z' -- store as is }
  sub     al, ('a' - 'A') { convert Character in AL to upper Case }
@notLower:
  stosb                   { Store upCased Character in String }
  loop    @UpCase         { Decrement CX, jump if not zero }
@Done:
  pop     ds              { Restore DS from stack }
end;

FUNCTION Uppercase(S : STRING) : STRING;
BEGIN
StrUpr(S);
Uppercase := S;
END;

FUNCTION LoCase (InChar : CHAR) : CHAR;
BEGIN
   IF InChar IN ['A'..'Z'] THEN
      LoCase := CHR (ORD (Inchar) + 32)
   ELSE
      LoCase := InChar
END;

FUNCTION FixLen (AnyString : STRING; PadChar : CHAR; FldSize : WORD) : STRING;
                                                             assembler;
asm
        PUSH    DS              {Save Data Segment}
        CLD                     {Clear direction flag}
        LDS     SI, AnyString    {DS:SI-->AnyString}
        LES     DI, @Result      {ES:DI-->String to be returned}
        MOV     BX, DI           {Save DI value for later}
        LODSB                   {AL has Length(AnyString)}
        CBW                     {Make AL into word in AX}
        STOSB                   {Put the length into Result & Inc(DI)}
        MOV     CX, AX           {Length in CX}
        REP     MOVSB           {Pad=AnyString}
        MOV     CX, FldSize      {CX has FldSize}
        XOR     CH, CH           {Make FldSize=FldSize mod 256}
        MOV     ES : [BX], CL      {Make Length(Pad)=FldSize}
        SUB     CX, AX           {CX=FldSize-Length(AnyString)}
        JB      @1              {Return truncated string if CX<0}
        MOV     AL, PadChar      {else load character to pad}
        REP     STOSB           {and pad to FldSize}
@1 :                             {Go back}
        POP     DS              {Restore Data Segment}
END;


FUNCTION PadR (InpStr : STRING; FieldLen : BYTE) : STRING;
BEGIN
PadR := FixLen (InpStr, #32, FieldLen);
END;

Procedure RightJustify(Var S: String; Width: Byte); Assembler;
Asm
   push    ds              { Save DS }
   lds     si, S           { Load Pointer to String }
   mov     al, [si]        { Move length Byte  in AL }
   mov     ah, Width       { Move Width in AH }
   sub     ah, al          { Subtract }
   jbe     @Done           { if Length(S) >= Width then Done... }
   push    si              { Save SI on stack }
   mov     cl, al
   sub     ch, ch          { CX = length of the String }
   add     si, cx          { SI points to the last Character }
   mov     dx, ds
   mov     es, dx          { ES = DS }
   mov     di, si          { DI = SI }
   mov     dl, ah
   sub     dh, dh          { DX = number of spaces to padd }
   add     di, dx          { DI points to the new end of the String }
   std                     { String ops backward }
   rep     movsb           { Copy String to the new location }
   pop     si              { SI points to S }
   mov     di, si          { DI points to S }
   add     al, ah          { AL = new length Byte }
   cld                     { String ops Forward }
   stosb                   { Store new length Byte }
   mov     al, ' '
   mov     cx, dx          { CX = number of spaces }
   rep     stosb           { store spaces }
@Done:
   pop     ds              { Restore DS }
end;

FUNCTION PadL(InpStr : STRING; Len : Byte) : STRING;
BEGIN
RightJustify(InpStr,Len);
PadL := InpStr;
END;

FUNCTION TrimB (InpStr : STRING) : STRING;
BEGIN
while (InpStr[0] > #0) and (InpStr[Length(InpStr)] = #32) do
         Dec(InpStr[0]);  { trim left }
  while (InpStr[0] > #0) and (InpStr[1] = #32) do
  begin
    Move(InpStr[2], InpStr[1], Pred(Length(InpStr)));
    Dec(InpStr[0]);
  end;
  TrimB := InpStr;
END;

PROCEDURE Replace (VAR S : STRING; NowChar, ReplaceChar : CHAR);
VAR i    : BYTE;
    SLen : BYTE ABSOLUTE S;
BEGIN
FOR i := 1 TO SLen DO
    IF S [i] = NowChar THEN S [i] := ReplaceChar;
END;


FUNCTION GetStr (VAR InpStr : STRING; Delim : CHAR) : STRING;
VAR i : INTEGER;
BEGIN
   i := POS (Delim, InpStr);
   IF i = 0 THEN BEGIN
      GetStr := InpStr;
      InpStr := ''
      END
   ELSE BEGIN
      GetStr := COPY (InpStr, 1, i - 1);
      DELETE (InpStr, 1, i)
      END
END;

{ ╔════════════════════════════════════════════════════════════════════════╗ }
{ ║                        PATH PROCEDURES AND FUNCTIONS                   ║ }
{ ╚════════════════════════════════════════════════════════════════════════╝ }

FUNCTION PathOnly (FileName : PathStr) : PathStr;
VAR
   Dir  : DirStr;
   Name : NameStr;
   Ext  : ExtStr;
BEGIN
   FSplit (FileName, Dir, Name, Ext);
   PathOnly := Dir;
END {PathOnly};

FUNCTION RootOnly (FileName : PathStr) : PathStr;
VAR
   Dir  : DirStr;
   Name : NameStr;
   Ext  : ExtStr;
BEGIN
   FSplit (FileName, Dir, Name, Ext);
   RootOnly := COPY (Dir, 1, 2) + '\';
END {RootOnly};

FUNCTION NameOnly (FileName : PathStr) : PathStr;
{ Strip any path information from a file specification }
VAR
   Dir  : DirStr;
   Name : NameStr;
   Ext  : ExtStr;
BEGIN
   FSplit (FileName, Dir, Name, Ext);
   NameOnly := Name + Ext;
END {NameOnly};

FUNCTION BaseNameOnly (FileName : PathStr) : PathStr;
{ Strip any path and extension from a file specification }
VAR
   Dir  : DirStr;
   Name : NameStr;
   Ext  : ExtStr;
BEGIN
   FSplit (FileName, Dir, Name, Ext);
   BaseNameOnly := Name;
END {BaseNameOnly};

FUNCTION ExtOnly (FileName : PathStr) : PathStr;
{ Strip the path and name from a file specification.  Return only the }
{ filename extension.                                                 }
VAR
   Dir  : DirStr;
   Name : NameStr;
   Ext  : ExtStr;
BEGIN
   FSplit (FileName, Dir, Name, Ext);
   IF POS ('.', Ext) <> 0 THEN
      DELETE (Ext, 1, 1);
   ExtOnly := Ext;
END {ExtOnly};

FUNCTION NameLessExt (FileName : PathStr) : PathStr;
{ Strip any extension from a file specification }
VAR
   Dir  : DirStr;
   Name : NameStr;
   Ext  : ExtStr;
BEGIN
   FSplit (FileName, Dir, Name, Ext);
   NameLessExt := Dir + Name;
END;

FUNCTION AddBackSlash(DirName : string) : string;
  {-Add a default backslash to a directory name}
begin
  if DirName[Length(DirName)] in ['\',':',#0] then
    AddBackSlash := DirName
  else
    AddBackSlash := DirName+'\';
end;


FUNCTION NoBackSlash (Path : PathStr) : PathStr;
{ Returns a path name that has its last backslash removed }
BEGIN
  IF (Path [LENGTH (Path) ] = '\') AND     { Last char of path is backslash }
     (Path <> '\') AND                    { Path is not a root directory }
     NOT ( (LENGTH (Path) = 3) AND (COPY (Path, 2, 2) = ':\') ) THEN
    DELETE (Path, LENGTH (Path), 1);                    { Delete backslash }
  NoBackSlash := Path;
END; { Nobackslash }

FUNCTION StripPathName (Path : PathStr) : PathStr;
{If path contains wildcard *.*,??? Then Strip away leaving only path}

VAR Temp, S : PathStr;
    Wild   : BYTE;

BEGIN
Path := NoBackSlash (Path);
S    := PathOnly(Path);
Temp := NameOnly(Path);
Wild := POS ('*', Temp) + POS ('?', Temp) + POS ('.', Temp);
IF Wild <> 0 THEN Path := S;
IF (LENGTH (Path) = 1) AND (UPCASE (Path [1]) IN ['A'..'Z']) THEN Path := Path + ':\';
IF Path [LENGTH (Path) ] <> '\' THEN Path := Path + '\';
StripPathName := Path;
END;


FUNCTION FullPathname (Path, FileMask : PathStr) : PathStr;
 BEGIN                     {FullPathname}
 Path     := TrimB (StripPathName (Path) );
 Filemask := TrimB (Filemask);
 IF POS (':', FileMask) + POS ('.', FileMask) > 0 THEN FileMask := NameOnly (FileMask);
 IF Path [LENGTH (Path) ] = '\' THEN
    DELETE (Path, LENGTH (Path), 1);        { Delete backslash }
 IF FileMask [1] = '\' THEN FileMask := COPY (FileMask, 2, LENGTH (FileMask) );
 FullPathName := FExpand (Path + '\' + FileMask);
 END;                      {FullPathname}

FUNCTION SameName (N1, N2 : STRING) : BOOLEAN;
{
  Function to compare filespecs.

  Wildcards allowed in either name.
  Filenames should be compared seperately from filename extensions by using
     seperate calls to this function
        e.g.  FName1.Ex1
              FName2.Ex2
              are they the same?
              they are if SameName(FName1, FName2) AND SameName(Ex1, Ex2)

  Wildcards work the way DOS should've let them work (eg. *XX.DAT doesn't
  match just any file...only those with 'XX' as the last two characters of
  the name portion and 'DAT' as the extension).

  This routine calls itself recursively to resolve wildcard matches.

}
VAR
   P1, P2 : INTEGER;
   Match  : BOOLEAN;
BEGIN
   P1    := 1;
   P2    := 1;
   Match := TRUE;

   IF (LENGTH (N1) = 0) AND (LENGTH (N2) = 0) THEN
      Match := TRUE
   ELSE
      IF LENGTH (N1) = 0 THEN
         IF N2 [1] = '*' THEN
            Match := TRUE
         ELSE
            Match := FALSE
      ELSE
         IF LENGTH (N2) = 0 THEN
            IF N1 [1] = '*' THEN
               Match := TRUE
            ELSE
               Match := FALSE;

   WHILE (Match = TRUE) AND (P1 <= LENGTH (N1) ) AND (P2 <= LENGTH (N2) ) DO
      IF (N1 [P1] = '?') OR (N2 [P2] = '?') THEN BEGIN
         INC (P1);
         INC (P2);
      END {then}
      ELSE
         IF N1 [P1] = '*' THEN BEGIN
            INC (P1);
            IF P1 <= LENGTH (N1) THEN BEGIN
               WHILE (P2 <= LENGTH (N2) ) AND NOT SameName (COPY (N1, P1, LENGTH (N1) - P1 + 1),COPY(N2,P2,LENGTH(N2)-P2+1)) DO
                  INC (P2);
               IF P2 > LENGTH (N2) THEN
                  Match := FALSE
               ELSE BEGIN
                  P1 := SUCC (LENGTH (N1) );
                  P2 := SUCC (LENGTH (N2) );
               END {if};
            END {then}
            ELSE
               P2 := SUCC (LENGTH (N2) );
         END {then}
         ELSE
            IF N2 [P2] = '*' THEN BEGIN
               INC (P2);
               IF P2 <= LENGTH (N2) THEN BEGIN
                  WHILE (P1 <= LENGTH (N1) ) AND NOT SameName (COPY (N1, P1, LENGTH (N1)-P1+1),COPY(N2, P2,LENGTH(N2)-P2+1)) DO
                     INC (P1);
                  IF P1 > LENGTH (N1) THEN
                     Match := FALSE
                  ELSE BEGIN
                     P1 := SUCC (LENGTH (N1) );
                     P2 := SUCC (LENGTH (N2) );
                  END {if};
               END {then}
               ELSE
                  P1 := SUCC (LENGTH (N1) );
            END {then}
            ELSE
               IF UPCASE (N1 [P1]) = UPCASE (N2 [P2]) THEN BEGIN
                  INC (P1);
                  INC (P2);
               END {then}
               ELSE
                  Match := FALSE;

   IF P1 > LENGTH (N1) THEN BEGIN
      WHILE (P2 <= LENGTH (N2) ) AND (N2 [P2] = '*') DO
         INC (P2);
      IF P2 <= LENGTH (N2) THEN
         Match := FALSE;
   END {if};

   IF P2 > LENGTH (N2) THEN BEGIN
      WHILE (P1 <= LENGTH (N1) ) AND (N1 [P1] = '*') DO
         INC (P1);
      IF P1 <= LENGTH (N1) THEN
         Match := FALSE;
   END {if};

   SameName := Match;

END {SameName};

FUNCTION Exist (FName : PathStr; GoodAttr : WORD) : BOOLEAN;
    {-Return true if file is found and attribute matches }
  VAR
    Regs : REGISTERS;
    FLen : BYTE ABSOLUTE FName;
  BEGIN
    {check for empty string}
    IF LENGTH (FName) = 0 THEN Exist := FALSE
    ELSE WITH Regs DO
    BEGIN
      IF IORESULT = 0 THEN ; {clear IoResult}
      INC (FLen);
      FName [FLen] := #0;
      AX := $4300;           {get file attribute}
      DS := SEG (FName);
      DX := OFS (FName [1]);
      MSDOS (Regs);
      Exist := (NOT ODD (Flags) ) AND (IORESULT = 0) AND
                   (CX AND GoodAttr <> 0);
    END;
  END;


{ ╔════════════════════════════════════════════════════════════════════════╗ }
{ ║                           SORTING FUNCTIONS                            ║ }
{ ╚════════════════════════════════════════════════════════════════════════╝ }


FUNCTION LessName (X, Y : DirPtr) : BOOLEAN;
BEGIN
  LessName := X^.Name < Y^.Name;
END;

FUNCTION LessExt (X, Y : DirPtr) : BOOLEAN;
VAR P   : BYTE;
    E, E1 : STRING [3];
BEGIN
    P := POS ('.', X^.Name);
    IF P > 1 THEN E := COPY (X^.Name, P + 1, 3)
    ELSE E := '';

    P := POS ('.', Y^.Name);
    IF P > 1 THEN E1 := COPY (Y^.Name, P + 1, 3)
    ELSE E1 := '';
  LessExt := E < E1;
END;

FUNCTION LessPath (X, Y : DirPtr) : BOOLEAN;
BEGIN
  LessPath := X^.Path < Y^.Path;
END;

FUNCTION LessSize (X, Y : DirPtr) : BOOLEAN;
BEGIN
  LessSize := X^.Size < Y^.Size;
END;

FUNCTION LessTime (X, Y : DirPtr) : BOOLEAN;
BEGIN
  LessTime := X^.Time < Y^.Time;
END;

FUNCTION LessAttr (X, Y : DirPtr) : BOOLEAN;
BEGIN
  LessAttr := X^.Attr < Y^.Attr;
END;

PROCEDURE QuickSort (L, R : INTEGER; VAR Page : SortPage; Less : LessFunc);
VAR
  I, J : INTEGER;
  X    : DirPtr;

  PROCEDURE ExchangeStructs(var I, J; Size : Word);
    inline(
      $FC/                     {cld             ;go forward}
      $8C/$DA/                 {mov dx,ds       ;save DS}
      $59/                     {pop cx          ;CX = Size}
      $5E/                     {pop si}
      $1F/                     {pop ds          ;DS:SI => J}
      $5F/                     {pop di}
      $07/                     {pop es          ;ES:DI => I}
      $D1/$E9/                 {shr cx,1        ;move by words}
      $E3/$0C/                 {jcxz odd}
      $9C/                     {pushf}
                               {start:}
      $89/$F3/                 {mov bx,si}
      $26/$8B/$05/             {mov ax,es:[di]  ;exchange words}
      $A5/                     {movsw}
      $89/$07/                 {mov [bx],ax}
      $E2/$F6/                 {loop start      ;again?}
      $9D/                     {popf}
                               {odd:}
      $73/$07/                 {jnc exit}
      $8A/$04/                 {mov al,[si]     ;exchange the odd bytes}
      $26/$86/$05/             {xchg al,es:[di]}
      $88/$04/                 {mov [si],al}
                               {exit:}
      $8E/$DA);                {mov ds,dx       ;restore DS}

BEGIN
  I := L;
  J := R;
  X := Page [ (L + R) DIV 2];
  REPEAT
    WHILE Less (Page [I], X) DO INC (I);
    WHILE Less (X, Page [J]) DO DEC (J);
    IF I <= J THEN
    BEGIN
      ExchangeStructs (Page [I], Page [J], SIZEOF (DirPtr) );
      INC (I);
      DEC (J);
    END;
  UNTIL I > J;
  IF L < J THEN QuickSort (L, J, Page, Less);
  IF I < R THEN QuickSort (I, R, Page, Less);
END;

{ ╔════════════════════════════════════════════════════════════════════════╗ }
{ ║                 INTERFACED PROCEDURES AND FUNCTIONS                    ║ }
{ ╚════════════════════════════════════════════════════════════════════════╝ }

FUNCTION FileTypePerExtension(fName : PathStr) : FileTypes;

VAR
     Ext : ExtStr;

BEGIN
   Ext := ExtOnly(Uppercase(fName));
   IF (fName = '.') OR (fName = '..') OR (fName = '\') OR
   (POS('\.',fName) + POS('..',fName) > 0) THEN
   FileTypePerExtension := fDIR ELSE
   IF (POS(Ext,'.ARC.PAK.ZIP.LZH.ARJ.ZOO.LBR.COM.EXE.BAT') = 0) THEN
   FileTypePerExtension := fOTHER ELSE
   FileTypePerExtension := FILETYPES(POS(Ext,'.ARC.PAK.ZIP.LZH.ARJ.ZOO.LBR.COM.EXE.BAT') div 4);
END;

FUNCTION FileTypeString (FT : FileTypes) : STRING;
BEGIN
CASE FT OF
    fARC   : FileTypeString := 'ARC';
    fPAK   : FileTypeString := 'PAK';
    fZIP   : FileTypeString := 'ZIP';
    fLBR   : FileTypeString := 'LBR';
    fZOO   : FileTypeString := 'ZOO';
    fLZH   : FileTypeString := 'LZH';
    fARJ   : FileTypeString := 'ARJ';
    fCOM   : FileTypeString := 'COM';
    fEXE   : FileTypeString := 'EXE';
    fBAT   : FileTypeString := 'BATCH';
    fSFX   : FileTypeString := 'SFX';
    fDIR   : FileTypeString := 'DIR';
    fVOL   : FileTypeString := 'VOLUME';
    fOTHER : FileTypeString := 'FILE';
    fERROR : FileTypeString := 'ERROR';
    ELSE FileTypeString := '';
    END;
END;

FUNCTION GetArcType (FName : PathStr) : FileTypes;
VAR
  ArcFile : FILE;
  i       : INTEGER;
  Gat     : FileTypes;
  c       : ARRAY [1..5] OF BYTE;
BEGIN
  ASSIGN (ArcFile, FName);
  RESET  (ArcFile,1);
  IF IORESULT <> 0 THEN
    Gat := fError
  ELSE
  IF FILESIZE (ArcFile) < 5 THEN
    Gat := fError
  ELSE
  BEGIN
    BLOCKREAD (ArcFile, c , 5);
    CLOSE (ArcFile);
    IF ( (c [1] = $50) AND (c [2] = $4B) ) THEN
      Gat := fZip
    ELSE
    IF ( (c [1] = $60) AND (c [2] = $EA) ) THEN
      Gat := fArj
    ELSE
    IF ( (c [4] = $6c) AND (c [5] = $68) ) THEN
      Gat := fLzh
    ELSE
    IF ( (c [1] = $5a) AND (c [2] = $4f) AND (c [3] = $4f) ) THEN
      Gat := fZoo
    ELSE
    IF ( (c [1] = $1a) AND (c [2] = $08) ) THEN
      Gat := fArc
    ELSE
    IF ( (c [1] = $1a) AND (c [2] = $0b) ) THEN
      Gat := fPak
    ELSE
      Gat := fOTHER;
  END;

  GetArcType := Gat;
END;

FUNCTION MethodString (Method : BYTE) : STRING;
CONST
    Stowage : ARRAY [0..12] OF STRING [9] =
      ('Stored', 'Shrunk', 'Stored', 'Packed', 'Squeezed', 'LZCrunch', 'LZCrunch',
      'LZW Pack', 'Crunched', 'Squashed', 'Crushed', 'Distilled', 'Frozen');
BEGIN
IF Method <= 12 THEN MethodString := PadR (Stowage [Method], 9)
   ELSE MethodString := '';
END;

PROCEDURE GetCommandLine (VAR Mask : PathStr);
VAR
   i : BYTE;
BEGIN
  Mask := '';
  IF PARAMCOUNT = 0 THEN EXIT;
  FOR I := 1 TO PARAMCOUNT DO Mask := Mask + ' ' + PARAMSTR (i);
  Mask := TrimB (UpperCase (Mask) );
END;

PROCEDURE UpdateNextPrev (VAR Dir : DirList);
{ This ASSUMES that Dirs is The LAST record added }
VAR
   Work : DirPtr;
BEGIN
    Dir.Current^.Next := NIL;
    Dir.Current^.Prev := NIL;
    IF Dir.Root = NIL THEN Dir.Root := Dir.Current
    ELSE BEGIN
         Work := Dir.Root;
         WHILE (Work^.Next <> NIL) DO Work := Work^.Next;
         Work^.Next     := Dir.Current;
         Dir.Current^.Prev := Work;
         Dir.Current^.Next := NIL;
         END;
Dir.Last    := Dir.Current;
END;

FUNCTION  NthDirItem (VAR Dir : DirList; Item : INTEGER) : DirPtr;
{ return nth dir item in list .. ZERO if the FIRST ITEM }
VAR
    W : DirPtr;
    C : INTEGER;
BEGIN
NthDirItem := NIL;
IF Item > Dir.Count THEN EXIT;
C := 0;
W := Dir.Root;
WHILE ( W <> NIL ) AND (C < Item) DO
      BEGIN
      INC (C);
      W := W^.Next;
      END;
NthDirItem := W;
END;

FUNCTION IsDir(fName : PathStr) : BOOLEAN;
BEGIN
IsDir := Exist(fName,Directory);
END;

FUNCTION IsArchive(fName : PathStr) : BOOLEAN;
BEGIN
IsArchive := NOT (GetArcType(fName) in [fOTHER,fERROR]);
END;

PROCEDURE FindFiles (VAR Dir : DirList; SearchPath : PathStr);
{ find files matching MASK on PATH }

VAR  F : SearchRec;

     FUNCTION IsDirectory(dPath : SearchRec) : BOOLEAN;
     BEGIN
     IsDirectory := (dPath.Attr = 16) AND (POS ('.',dPath.Name) = 0);
     END;

     FUNCTION IsGoodFile (dFile : SearchRec) : BOOLEAN;
     VAR
         i : BYTE;
         Check,
         TempMask : STRING;

     BEGIN

     IsGoodFile := TRUE;

     IF Dir.Mask = '*.*' THEN EXIT;  { we want ALL of them }

     IsGoodFile := FALSE;
     TempMask   := Dir.Mask;

     WHILE TempMask <> '' DO
         BEGIN
         Check := GetStr(TempMask,#32);
         IF Check = '' THEN EXIT;
         IF SameName (Check, dFile.Name) OR
            (Check = '*.*') THEN
            BEGIN
            IsGoodFile := TRUE;
            EXIT;
            END;
         END;

     END;

BEGIN

  WITH Dir DO
  BEGIN
  IF Dir.Mask = '' THEN Dir.Mask := '*.*';
  FINDFIRST (FullPathName (SearchPath, '*.*'), AnyFile, F);
  WHILE (DosError = 0) AND (Count < MaxDirSize) DO
  BEGIN
    IF IsGoodFile (F) AND ( POS (SilentDirStr, F.Name) = 0 ) AND
       (MaxAvail > SizeOf (DirRec) + 1024) THEN
       BEGIN
       GETMEM (Current , SIZEOF (DirRec) );
       Current^.Attr  := F.Attr;
       Current^.Time  := F.Time;
       Current^.Size  := F.Size;
       Current^.Name  := F.Name;
       Current^.Path  := SearchPath;
       IF (F.Attr AND Directory <> 0) THEN
       Current^.FType := fDIR ELSE
       IF (F.Attr AND VolumeID <> 0) THEN
       Current^.FType := fVOL ELSE
       Current^.FType := FileTypePerExtension(F.Name);
       Current^.Tag   := FALSE;
       UpdateNextPrev (Dir);
       INC (Dir.Count);
       INC (Dir.Space, F.Size);
       END ELSE IF IsDirectory(F) AND (Dir.Recurse) THEN
                   FindFiles(Dir,FullPathName(SearchPath,F.Name));
  FINDNEXT (F);
  END;

  END; { With }
END;

PROCEDURE SortFiles (VAR Dir : DirList);
VAR
   Page : sortPPtr;
   Idx  : INTEGER;
   W    : DirPtr;

BEGIN

  IF (Dir.Count <> 0) AND (@Dir.Less <> NIL) THEN
      BEGIN
      New(Page);
      FILLCHAR (Page^, SIZEOF (Sortpage), #0);
      Idx := 0;
      W   := Dir.Root;
      FOR Idx := 0 TO PRED (Dir.Count) DO
         BEGIN
         Page^ [idx] := W;
         W         := W^.Next;
         END;

      QuickSort ( 0, idx, Page^, Dir.Less );

      Dir.Root := NIL;
      Dir.Last := NIL;
      Dir.Current := NIL;

      FOR Idx := 0 TO PRED (Dir.Count) DO
          BEGIN
          Dir.Current := Page^ [idx];
          UpdatenextPrev (Dir);
          END;

      Dispose(Page);
      END;

END;

PROCEDURE SetLess (VAR Dir : DirList; LChar : CHAR);
BEGIN
  CASE LoCase (LChar) OF
   'n' : Dir.Less := LessName;
   'e' : Dir.Less := LessExt;
   'a' : Dir.Less := LessAttr;
   'd' : Dir.Less := LessTime;
   's' : Dir.Less := LessSize;
   'p' : Dir.Less := LessPath;
    ELSE Dir.Less := LessName;
 END; { case }
CurrentLess := LChar;
END;

PROCEDURE InitializeDir (VAR Dir : DirList);

BEGIN
  FILLCHAR (Dir, SIZEOF (DirRec), #0);
  Dir.Root := NIL;
  Dir.Last := NIL;
  Dir.Current := NIL;
  SetLess (Dir, CurrentLess);
  GETDIR (0, Dir.Path);
END;

PROCEDURE ReleaseFiles (VAR Dir : DirList);

VAR
  I : INTEGER;
  W : DirPtr;

BEGIN

  IF Dir.Count > 0 THEN
  BEGIN
  W := Dir.Root;
  FOR I := 0 TO PRED (Dir.Count) DO
      BEGIN
      Dir.Current := W;
      IF W <> NIL THEN FREEMEM (W, SIZEOF (DirRec) );
      W := dir.Current^.Next;
      END;
  END;

  { Do Not Want to initialize all of it }

  Dir.Count   := 0;
  Dir.Space   := 0;
  Dir.Tagged  := 0;
  Dir.TSpace  := 0;
  Dir.Root    := NIL;
  Dir.Last    := NIL;
  Dir.Current := NIL;


END;

FUNCTION DosTime (Date, Time : WORD) : LONGINT;

  VAR
    DT : DateTime;
    FT : LONGINT;

BEGIN

    WITH DT DO
         BEGIN
         day   := date AND $001F;
         month := (date SHR 5) AND $000F;
         year  := ( (date SHR 9 + 80) MOD 100) + 1900;

         min    := (time SHR 5) AND $003F;
         hour   := time SHR 11;
         Sec    := 0;
         END;

PACKTIME (DT, FT);
DosTime := FT;
END;


PROCEDURE SaveArchiveEntry ( VAR  Dir       : DirList;
                                  File_Name : PathStr;
                                  File_Path : PathStr;
                                  Size_Now  : LONGINT;
                                  Size_Then : LONGINT;
                                  File_Time : LONGINT;
                                  MethodStr : STRING);
BEGIN


          WITH Dir DO
          BEGIN
            GETMEM (Current, SIZEOF (DirRec) );
            Current ^.Attr   := 32;
            Current ^.Time   := File_Time;
            Current ^.Size   := Size_Then;
            Current ^.PSize  := Size_Now;
            Current ^.Method := MethodStr;
            Current ^.Name   := PadR (File_Name, 12);
            Current ^.Path   := NoBackSlash (File_Path);
            IF Current ^.Path <> '' THEN
               BEGIN
               IF (Current ^.Path [1] <> '\') AND
                  (POS (':\', Current ^.Path) = 0) THEN
                  Current ^.Path := '\' + Current ^.Path;
               END;
            Current^.FType   := FileTypePerExtension(File_Name);
            Current ^.Tag    := FALSE;
            UpdateNextPrev (Dir);
            INC (Dir.Count);
            INC (Dir.Space, Size_Then);
            END;

END { SaveArchiveEntry };

Procedure ZipView(VAR Dir : DirList; ZIPFile : String);  { View the ZIP File }
Const
  SIG = $04034B50;                  { Signature }
Type
  ZFHeader = Record                 { Zip File Header }
    Signature  : LongInt;
    Version,
    GPBFlag,
    Compress,
    Time,Date  : Word;
    CRC32,
    CSize,
    USize      : LongInt;
    FNameLen,
    ExtraField : Word;
  end;

Var
  Hdr     : ^ZFHeader;
  F       : File;
  S       : String;

  Label Terminate;

Const
  CompTypes : Array[0..7] of String[9] =
              ('Stored ','Shrunk   ','Reduced1','Reduced2','Reduced3',
               'Reduced4','Imploded ','Deflated');
  { Method used to compress }

begin

  New(Hdr);
  Assign(F,ZIPFile);
  {$I-}
  Reset(F,1);                            { Open File }
  {$I+}
  If IOResult <> 0 then GOTO Terminate;  { Couldn't open Zip File }

  Repeat
    FillChar(S,SizeOf(S), #0);  { Pad With nulls }
    BlockRead(F,Hdr^,SizeOf(ZFHeader));

    { Read File Header }
    BlockRead(F,Mem[Seg(S) : Ofs(S) + 1], Hdr^.FNameLen);
    s[0] := Chr(Hdr^.FNameLen);

  IF (Hdr^.Signature = Sig) Then { Is a header }
  SaveArchiveEntry(Dir,NameOnly(S),PathOnly(S),Hdr^.CSize,Hdr^.USize,DosTime(Hdr^.Date,Hdr^.Time),CompTypes[Hdr^.Compress]);

  Seek(F,FilePos(F) + Hdr^.CSize + Hdr^.ExtraField);
  Until Hdr^.Signature <> SIG; { No more Files }

  TERMINATE :

  Close(F);
  Dispose(Hdr);
end;

PROCEDURE ArjView(VAR Dir : DirList; ArjFile : String);

Type
  AFHeader = Record  { ArjFileHeader }
    HeadID,
    HdrSize   : Word;
    HeadSize,
    VerNum,
    MinVerNum,
    HostOS,
    ArjFlag,
    Method,
    FType,
    Reserved  : Byte;
    FileTime,
    PackSize,
    OrigSize,
    FileCRC   : LongInt;
    FilePosF,
    FileAcc,
    HostData  : Word;
  end;

Var
  b      : Byte;
  f      : File;
  sl     : LongInt;
  NR     : Word;
  FHdr   : ^AFHeader;
  s      : String;
  l      : String[80];
  i,e,ff : Integer;

  Label Terminate;

Const
  CompTypes : Array[0..4] of String[9] = ('Stored','Most',
              '2nd Most','2nd Fast','Fastest');


begin

  New(FHdr);
  Assign(f, arjFile);
  {$I-}
  Reset(F, 1);                     { Open File }
  {$I+}
  If IOResult <> 0 then GOTO Terminate; { Specified File exists?}
  SL := 0;
  FF := 0;
  Repeat

    Inc(FF);
    Seek(F,SL);
    BlockRead(F,FHdr^,SizeOf(AFHeader),NR);     { Read the header }

    If (NR = SizeOf(AFHeader)) Then
    BEGIN
      s := '';
      Repeat
        BlockRead(F,B,1);               { Get Char For Compressed Filename }
        If B <> 0 Then
          s := s + Chr(b);              { Put Char in String }
      Until B = 0;                      { Until no more Chars }

    L := GetStr(S,'/');
    IF S = '' THEN S := L;              { draw off path info }
    IF S = L THEN L := '';

    IF FF > 1 THEN
    SaveArchiveEntry(Dir,S,L,FHdr^.PackSize,FHdr^.OrigSize,FHdr^.Filetime,CompTypes[FHdr^.Method])
    ELSE FHdr^.Packsize := 0;  { Main Header - DO NOT WANT }

      Repeat
        BlockRead(F,B,1);
      Until b = 0;
      BlockRead(F,FHdr^.FileCRC,4);      { Go past File CRC }
      BlockRead(f,NR,2);

      SL := FilePos(F) + FHdr^.PackSize; { Where are we in File? }

  END;

  Until (FHdr^.HdrSize = 0);  { No more Files? }

TERMINATE :

  Close(f);
  Dispose(FHdr);  { Done }
end;

PROCEDURE LzhView(VAR Dir : DirList; LzhFile : String);

Type
  FileheaderType = Record  { Lzh File header }
    Headsize,
    Headchk   : Byte;
    HeadID    : packed Array[1..5] of Char;
    Packsize,
    Origsize,
    Filetime  : LongInt;
    Attr      : Word;
    Filename  : String[12];
    f32       : PathStr;
    dt        : DateTime;
  end;

Var

  Fh         : FileheaderType;
  Fha        : Array[1..sizeof(FileheaderType)] of Byte Absolute fh;
  crc        : Word;   { CRC value }
  crcbuf     : Array[1..2] of Byte Absolute CRC;
  crc_table  : Array[0..255] of Word; { Table of CRC's }
  inFile     : File; { File to be processed }

  oldFilepos : LongInt;
  numread,i  : Word;

  Label TERMINATE;

Procedure Make_crc_table;
Var
  i,
  index,
  ax    : Word;
  carry : Boolean;
begin
  index := 0;
  Repeat
    ax := index;
    For i := 1 to 8 do
    begin
      carry := odd(ax);
      ax := ax shr 1;
      if carry then
        ax := ax xor $A001;
    end;
    crc_table[index] := ax;
    inc(index);
  Until index > 255;
end;

{ use this to calculate the CRC value of the original File }
{ call this Function afer reading every Byte from the File }
Procedure calccrc(data : Byte);
Var
  index : Integer;
begin
  crcbuf[1] := crcbuf[1] xor data;
  index := crcbuf[1];
  crc := crc shr 8;
  crc := crc xor crc_table[index];
end;


Function Mksum : Byte;  {calculate check sum For File header }
Var
  i : Integer;
  b : Byte;
begin
  b := 0;
  For i := 3 to fh.headsize+2 do
    b := b+fha[i];
  mksum := b;
end;

begin
  assign(inFile,LZHFile);
  {$I-}
  reset(inFile,1);   { Open LZH File }
  {$I+}
  If IOResult <> 0 then GOTO Terminate;   { Specified File exists? }
  oldFilepos := 0;       { Init Variables }
  Repeat
    seek(inFile,oldFilepos);
    {Goto start of File}
    blockread(inFile,fha,sizeof(FileheaderType),numread);
    {Read Fileheader}
    oldFilepos := oldFilepos+fh.headsize+2+fh.packsize;
    { Where are we? }
    i := Mksum; { Get the checksum }

    if fh.headsize <> 0 then
    begin

      if i <> fh.headchk then
      begin
        Writeln('Error in File. Unable to read.  Aborting...');
        GOTO Terminate;
      end;

    SaveArchiveEntry(Dir,NameOnly(Fh.Filename),PathOnly(Fh.Filename),FH.PackSize,FH.OrigSize,FH.Filetime,'Frozen')
    end;
  Until   (fh.headsize=0);

  TERMINATE :
  Close(infile);

END;

PROCEDURE ArcView(VAR Dir : DirList; ArcName : PathStr);

Type ARCHead = Record
                 ARCMark   : Char;
                 ARCVer    : Byte;
                 FN        : Array[1..13] of Char;
                 CompSize  : LongInt;
                 Dos_DT    : LongInt;
                 CRC       : Word;
                 UCompSize : LongInt;
               end;
Const ARCFlag : Char = #26;                                        { ARC mark }
      Stowage : ARRAY [0..12] OF STRING [9] =
       ('Stored', 'Shrunk', 'Stored', 'Packed', 'Squeezed', 'LZCrunch', 'LZCrunch',
       'LZW Pack', 'Crunched', 'Squashed', 'Crushed', 'Distilled', 'Frozen');

Var WLV   : LongInt;                               { Working LongInt Variable }
    ARC1  : ARCHead;
    QUIT  : Boolean;                             { "end" sentinel encountered }
    F     : File;
    I,
    Res   : Word;
    FSize,
    C     : LongInt;
    SName : PathStr;
    BUFF  : Array[1..4096] of Byte;

Procedure GET_ARC_ENTRY;
begin
  FillChar(ARC1,SizeOf(ARCHead),#0);
  Seek (F,C);
  BlockRead (F,BUFF,SizeOf(ARCHead),RES);
  Move (BUFF[1],ARC1,SizeOf(ARCHead));
  With ARC1 do
    if (ARCMark = ARCFlag) and (ARCVer > 0) then
      begin
        SNAME := '';
        I := 1;
        While FN[I] <> #0 do
          begin
            SNAME := SNAME+FN[I]; Inc(I)
          end;
        WLV := (Dos_DT Shr 16)+(Dos_DT Shl 16);              { flip Date/Time }
        FSize := CompSize;
      end;
    QUIT := ARC1.ARCVer <= 0;
end;  { GET_ARC_ENTRY }

begin
  Assign (F,ArcName);
  Reset (F,1);
  C := 0;
  Repeat
    GET_ARC_ENTRY;
    if not QUIT then
       SaveArchiveEntry(Dir,NameOnly(Sname),PathOnly(Sname),ARC1.CompSize,ARC1.UCompSize,WLV,Stowage[ARC1.ArcVer]);
    Inc (C,FSize+SizeOf(ARCHead))
  Until QUIT;
  Close (F);
end;

PROCEDURE GetFiles(VAR Dir : DirList; Path,Mask : PathStr; Sort : LessFunc);
{ get either Directory or Archive depending on file type and store in list }
VAR
    Default : FileTypes;

BEGIN

  InitializeDir (Dir);
  Dir.Less    := Sort;
  Dir.Mask    := Mask;
  Dir.Path    := AddBackSlash(Path);
  Dir.ArcType := fDIR;

  IF IsDir(Path) Then FindFiles(Dir,Path) ELSE
     BEGIN
     Default := GetArcType(Path);
     Case Default OF
     fARC : ArcView(Dir,Path);
     fPAK : ArcView(Dir,Path);
     fZIP : ZipView(Dir,Path);
     fARJ : ArjView(Dir,Path);
     fLZH : LzhView(Dir,Path);
     END;
     Dir.ArcType := Default;
     END;

  { load current path if filename isn't dir or archive }

  IF Dir.Count > 0 THEN SortFiles(Dir) ELSE
     BEGIN
     GetDir(0,Dir.Path);
     FindFiles(Dir,Dir.Path);
     SortFiles(Dir);
     Dir.ArcType := fDIR;
     END;

END;

END.